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The  work  performed  to  meet  the  requirement  of  this  task  is  a  con¬ 
tinuing  effort,  evolving  toward  a  general  purpose  reasoning  tool. 
The  idea  here  is  to  buijji^a  more  powerful  general  expert  system 
than  the  previous  one  *{44 .  Towards  that,  this  new  Bayesian  infer¬ 
ence  engine  is  based  on  the  work  done  by  Pearl  and  K i rrffiB The 
advantages  of  this  new  inference  engine  over  the  previous  one  are 
that  the  representation  of  the  knowledge  is  more  compact  and  the 
inferencing  is  suitable  for  parallel  processing. 


The  inference  engine  is  written  in  Franz  lisp  on  VAX  machine.  All 
the  code  ar\d  a  typescript  of  how  to  load  and  use  the  system  is 
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[1]  Booker  L.  B.,  An  Artificial  Intelligence (AI)  Approach  to  Ship 
Classsification .  In  Intelligent  Systems:  Their  Development  and 
Application.  Proceedings  of  the  24th  Annual  Technical  Symposi¬ 
um,  Washigton  D.C.  Chapter  of  the  ACM.  Gaithersburg,  MD.,  June, 
1985,  p.  29-35. 

[2]  Kim,  J.  and  Pearl,  J.,  A  computational  Model  for  Combined 
Causal  and  Diagnostic  Reasoning  in  Inference  Systems,  Proceed¬ 
ings  of  IJCAI-83,  Los  Angles,  CA.,  August,  1983,  p.  190-193. 
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typescnpt 


cat-  Is 

README 

bench 


driverl .o 


met* 

iat/ 

iriverl . 1 


mit .  i 
init .  o 
mat .  i 


meters  < 
net-img. 1 
net-img.o 
net .  i 


test . 1 
typescript 


rtk780.c 

rtk780.o 

safe/ 


2 . fas  1  net-img 
! fas  I  net-imgi 
[  fas  1  mat . o ] 
ifasl  init.o] 


3.fasl  driver! 

[fasl  driver!] 

/usr/local/iib/lisp/nld  -N  -x  -A  /usr/aic/hota/bin/lisp  -T  f4c00  /usr/aic/hota/doc/study/cnet/examples/ca 


4 .  rtk-open 
0 

5 .  whichleve 1 
2 

6 . mfork 
2 

7 .  whichlevel 
2 

8 . load-init 


Name  of  the  input  file  to  load  :  dat/reagan 
Ifasl  dat/ reagan .o] 


Initialize  ?  n 


Target  node  :  reagan 
nil 

9 . showbelief s 


belief  of  relations_with  soviets  is 

(0.5  0.5) 

belief  of  democrat ic_noroinee  is  (0.3333  0.3333  0.3333) 

belief  of  -Japanese  is  (0.5  0.5) 

belief  of  opec_oil_prices  is  (0.5  0.5) 

belief  of  economic_status  is  (0.4119  0.3259  0.2622) 

belief  of  reagan  is  (0.6747  0.3253) 


10 . showcons 


pi  lambda 

lk -re lat ions_with_soviet s-> reagan 

— >  (0.5  0.5)  (0.5  0.5) 

lk-democrat ic_nominee-> reagan 

-->  (0.3333  0.3333  0.3333)  (0.3333  0.3333  0.3333) 

lk- japanese->economic_status 

— >  (0.5  0.5)  (0.5  0.5) 

lk-opec_oi i_pr ices->economic_status 

-->  (0.5  0.5)  (0.5  0.5) 

lk-economic_st at us-> reagan 

-->  (0.4119  0.3259  0.2622)  (0.3333  0.3333  0.3333) 


11  .change-causes 


opec_oil_pricess  values  are  : (increased  decreased) 
prior  values:  (1.0  1.0) 

Enter  new  evidence  :  (.3  .7) 


japaneses  values  are  :  (cooperative  noi._coope rat i vei 
prior  values:  (1.0  1.0) 

Enter  new  evidence  :  (.7  .3) 


democrat ic_nominees  values  are  : (mondale  cranston  kennedy) 
prior  values:  (1.0  1.0  1.0) 

Enter  new  evidence  :  (.5  .4  .1) 


re lat ions_with_so viet ss  values  are  :  (friendly  not_f r iendly) 
prior  values:  (1.0  1.0) 

Enter  new  evidence  :  (.4  .6) 


ree 1 ected 


*•  J,j  •  .*  A.t  "  *  *  .  ' *  ‘  P  '  '  .t  J  !|  f  *1 


w 

S'jS 

$ 

V,»i' 

V«.i 

? 

■<5M 

*»;$! 

Sfij 

I 

$8 

( 


w 

V»:« 


$ 

ft 

i 

f 

i 

m 


fail 

12  .showbeliefs 


typescript 


— * >  0.273U 


belief  of  re lat ions_with_soviet s  is 

(0.4  0.6) 

belief  of  democrat ic_nominee  is  (0.5  0.4  0.1) 
belief  of  japanese  is  (0.7  0.3) 

belief  of  opec_oi l_pr ices  is  (0.3  0.7) 

belief  of  economic_st atus  is  (0.5002  0.2686  0.2312) 

belief  of  reagan  is  (0.7269  0.2731) 

13 . showcons 


pi  lambda 

Ik- re lat ion s_with_soviets-> reagan 

— >  (0.4  0.6)  (0.5  0.5) 

ik-democrat ic_nominee->reagan 

— >  (0.5  0.4  0.1)  (0.3333  0.3333  0.3333) 

lk- japanese ->economic_st at us 

— >  (0.7  0.3)  (0.5  0.5) 

lk-opec_oil_prices~>economic_status 

— >  (0.3  0.7)  (0.5  0.5) 

1 k-economic_st at us-> reagan 

— >  (0.5002  0.2686  0.2312)  (0.3333  0.3333  0.3333) 

14  .  targetnode 
reagan 
I 5. bye 
(11416  .  0) 

7  .bye 

77. 8u  18.3s  9:57  16%  173+1177k  98  +  37io  658pf+0w 
cat-  exit 


r.'i1 


(pucd  'bye  (getd  'exit)) 

(putd  '  +  (getd  'plus)) 

(pucd  (getd  'difference)) 

(putd  '*  (getd  'times)) 

(putd  '/  (getd  'quotient)) 

(putd  '=  (getd  'equal)) 

(putd  '**  (getd  'expt)) 

(putd  'S  (getd  'and)) 

(putd  '  !  (getd  '  or)  ) 

(putd  '-  (getd  'not)) 

(putd  '@  (getd  'mapcar)  ) 

;;;  -=-=-=-=-=-=-=-=  ut lmac . 1-=-=-=-=-=-=-= 

(declare  (macros  t)) 

(defmacro  incf  (place  Soptional  (delta  1) ) 

'(setf  .place  (+  .place  .delta))) 

(defmacro  i.ncf-f  (place  soptional  (delta  1)  ) 

'  (setf  .place  (  +  $  .place  .delta))) 

(defmacro  decf  (place  Soptional  (delta  1) ) 

'(setf  .place  (-  .place  .delta))) 

(defmacro  decf-f  (place  Soptional  (delta  1)) 

'(setf  .place  (-$  .place  .delta))) 

(defmacro  f or-each ( fe% 1  fe%2  srest  feirest) 

'(do  ((,fe%l  (car  ,fe%2)  (car  fe%3)) 

(fe%3  (cdr  ,fe%2)  (cdr  f e%3 ) ) ) 

(  (null  ,  fe%l)  nil) 

.(cons  ' progn  fe%rest) ) ) 

.•(defmacro  while  (whitest  srest  whibody) 

;  ' (do  ( ) 

;  ((not  .whitest)  nil) 

;  .(cons  'progn  whibody) ) ) 

; (defmacro  while  (whitest  srest  whibody) 

;  (let  ((ilp  (gensym) ) ) 

;  ' (prog  nil  , ilp 

;  (or  .whitest  (return  nil)) 

;  , @whibody 

;  (go  ,  ilp)  )  )  ) 

(defmacro  ttyesno()  ’  (yesno  (read))) 

(defun  yesno (atm) 

(or  (*=  atm  't) 

(=  atm  ' y) 

(=  atm  'ye) 

(=  atm  ' yes) ) ) 

(defvar  whichlevel  1) 

(defun  mforkl  macro (1) 

(list  ' cond  '((fork)  (wait)))) 

(defun  mfork  0 

(or  (mforkl)  (setq  whichlevel  (1+  whichlevel)))) 

(defun  f lambda  macro  (fl) 

(list  'function  (cons  'lambda  (cdr  fl)))) 

(defmacro  lastcar  (l_c_x) 

'(car  (last  , l_c_x) ) ) 

;;;  -=-=-=-=-=-=-=-=  flavinit.l 
(declare  (macros  t) ) 

(declare  (special  myhash) ) 

(setq  myhash  (make-equal-hash-table)) 

(defflavor  object+info  ((insts  nil) 

(parents  nil) 

(children  nil) ) 

0 

:  settable- instance -variables) 

(defmetnod  (object  +  info  :addmore)  (slot  val) 

(cond  ((member  val  (symeval-in-instance  self  slot))) 


(t  (set-in-instance  self  slot 

(cons  val  (symeval-in-instance  self  slot)))))) 

(defun  mdefflavor  macro  (rl) 

'  (progn  'compile 

(puthash-equal  (cons  (quote  , (cadr  rl))  '(+info)) 
(make-instance  ' ob ject+info)  myhash) 

(cond  (,  (cadddr  rl) 

(set-in-instance  (gethash-equal 

(cons  (quote  ,  (cadr  rl) )  '  (  +  info) ) 
myhash)  'parents  , (cadddr  rl) ) 
(for-each  x  ,  (cadddr  rl) 

(send  (gethash-equal  (cons  x  '  (  +  info) )  myhash) 
':addmore  'children  , (cadr  rl))))) 

, (cons  'defflavor  (cdr  rl)))) 

(defun  mmake-instance  macro (rin) 

’(progn  'compile 

(send  (gethash-equal  (cons  ,  (caddr  rin)  '  (  +  info) )  myhash) 
':addmore  ' insts  , (cadr  rin)) 

(puthasn-equai  ,  (caar  rin) 

, (cons  ' make-instance  (cddr  rin))  myhash))) 


(defmacro  msend  (objnam  slotnam  Soptional  (slotval  nil  slotvalp) ) 
’(send  (gethash-equal  , objnam  myhash)  , slotnam 
,@(if  slotvalp  (list  slotval)))) 

(defmacro  get-insts (obj) 

’(send  (gethash-equal  (cons  ,obj  '(+info))  myhash)  ':insts)) 
(defun  myfix  (num  lis) 

(do  (fans  nil  (cons  (fix  (*$  (car  tmp)  num))  ans)) 

(tmp  lis  (cdr  tmp) ) ) 

( (null  tmp)  (nreverse  ans) ) ) ) 

(defun  myfloat  (num  lis) 

(setq  num  (float  num)) 

(do  (  (ans  nil  (cons  (/$  (car  tmp)  num)  ans) ) 

(tmp  lis  (cdr  tmp) ) ) 

( (null  tmp)  (nreverse  ans) ) ) ) 


mat.l 


-K'5 
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(eval-when  (load  compile  eval)  (load  'init.o)) 

;;;  -=-«-=-=-=  Mat . L  -=-=-=-=-=-= 

(declare  (macros  t) ) 

(declare  (special  myinpport  precision  myhash  retval) ) 

;  -=-«—=-=  remove-duplicates 

(defun  remove-duplicates  (1st  Soptional  (from-end  nil)) 

(do  ( (ans  (cond  (from-end  (cdr  1st))  (t  (car  (reverse  1st))))) 
(mark  (cond  (from-end  (list  (car  1st)))  (t  (last  1st))) 
(cond  (ans  (tons  (car  ans)  mark))  (t  mark)))) 

((null  ans)  (cond  (from-end  (reverse  mark)) 

(t  mark) ) ) 

(setq  ans  (remove  (car  mark)  ans)))) 


;  -  -----  -  -  normalizing  -=-=-=-■=-= 

;  (norm  '  ( . 2  . 3) )  =>  ( . 4  .6) 

(defun  norm(lst) 

(let  ((sum  (apply  ' +$  1st))) 

(declare  (flonum  sum)) 

(cond  ( (zerop  sum) 

(listsomany  (length  1st)  (/$  1.0  (length  1st)))) 
(t  (do  (  (ansi  nil 

(cons  (/$  (car  lstl)  sum)  ansi) ) 
(lstl  1st  (cdr  lstl))) 

((null  lstl)  (nreverse  ansi))))))) 


outer  product  -=-=-=-=-= 
’(12)  '  (.2  .3) )  =>  (.2  .3  .4 


.24  .32) 


;  (outerpro2  '(1  2)  '(.2  .3))  =>  (.2  .3  .4  .6) 

(defun  outerpro2(ll  12) 

(do  ( (ans  nil 

(append 

(do  ( (xelt  tmp2  (cdr  xelt) ) 

(tmplcar  (car  tmpl) ) 

(ansi  nil  (cons  (*$  tmplcar  (car  xelt))  ansi))) 
(  (null  xelt)  ansi) ) 
ans)  ) 

(tmpl  (reverse  11)  (cdr  tmpl)) 

(tmp2  (reverse  12))) 

( (null  tmpl)  ans) ) ) 

; (outerpro  '((1  2)  (.2  .3)  (.4  .5)))  =>  (.08  .1  .12  .15  .16  .2  .24  .32) 

(defun  outerpro (1) 

(do  ((ans  (lastcar  1) 

(do  ((xelt  (car  nav)  (cdr  xelt)) 

(ansi  nil) ) 

((null  xelt)  (nreverse  ansi)) 

(do  ( (yelt  ans  (cdr  yelt)) 

(xeltcar  (car  xelt))) 

(  (null  yelt) ) 

(setq  ansi  (cons  (*S  xeltcar  (car  yelt))  ansi))))) 
(nav  (cdr  (reverse  1))  (cdr  nav))) 

(  (null  nav)  ans) ) ) 

;  (outerpromany  '(((-2  .3)  (.4  .5))  ((.1  .2)  (.3  .4)))) 

;  =>  ((.08  .1  .12  .15)  (.03  .04  .06  .08)) 

(defun  outerpromany  (lis) 

(do  (  (ans  nil  (cons  (outerpro  (car  tmp)  )  ans)  ) 

(tmp  lis  (cdr  tmp)  )  ) 

( (null  tmp)  (nreverse  ans) ) ) ) 


-r*p|j»V*4 


(eval-when  (load  eval)  (putd  'aref  (getd  'funcall))) 
(defsetf  aref  (e  v)  '(funcall  ,  (cadr  e)  ,v  ,@(cddr  e))) 
(defvar  *maklis-tmp*  (‘array  nil  t  10)) 

(setf  (aref  *maklis-tmp*  0)  nil) 

(loop  for  i  from  1  to  9 

do  (setf  (aref  *maklis-tmp*  i) 

(append  (aref  *maklis-tmp*  (1-  i ) ) 

(list  i) )  )  ) 

;  (maklis  3)  =>  (1  2  3) 

(defun  maklis(n) 

(declare  (fixnum  n) ) 

(cond  ( (<  n  10)  (aref  *maklis-tmp*  n) ) 

(t  (append  (maklis  (1-  n) )  (list  n) ) ) ) ) 


;  (listsomany  4  A)  =>  (AAA  A) 
(defun  listsomany  (1  e) 

(declare  (fixnum  1)) 


wx£«r>;: 


mat.l 


(cond  ( (<  1  1) 
((=  1  1) 
(t  (cons 


nil) 

(list  e) ) 
e  (listsomany  (- 


1  1)  e) )  )  )  ) 


;  (iisdiv  '(12345)  3)  =>  ((123)  (4  5)) 

(defun  Iisdiv  (lis  nl) 

(declare  (fixnum  nil) 

(let  (txl)) 

(while  (>  nl  0) 

(setq  xl  (cons  (car  lis)  xl) 
lis  (cdr  lis) 
nl  (1-  nl) ) ) 

(list  (nreverse  xl)  lis))) 

(defun  lisdivrec  (lis  nl) 


(do  ( (ans  nil 

(cons 


(trap  lis) ) 
( (null  tmp) 


(do  (  (ansi  nil  (cons  (car  tmp)  ansi) ) 
(junk  nil  (setq  tmp  (cdr  tmp))) 
(n2  nl  (1-  n2 ) ) ) 

((zerop  n2)  (nreverse  ansi))) 
ans)  ) 

(nreverse  ans)  )  )  ) 


;  term  product 

;  (termpro2  '(1  2)  '(3  4))  =>  (3  0) 
(defun  termpro2(ll  12) 

(do  ( (ans  nil  (cons  (*$  (car  tmpl) 
(tmpl  11  (cdr  tmpl) ) 

(tmp2  12  (cdr  tmp2)  )  ) 


;  (termpro  ' ( (1  2) 

(defun  termpro  (1) 

(do  ( (ans  (car  1) 

(do  ( (ansi 
(tmpl 
(tmp2 
(  (null 


(car  tmp2) )  ans) ) 


nil  (cons  (*?  (car 
ans  (cdr  tmpl)  ) 

(car  nav)  (cdr  tmp2))) 
tmpl!  (nreverse  ansi) )  )  ) 


ansi)  ) 


(nav  (cdr  1)  (cdr  nav)  )  ) 

(  (null  nav)  ans) ) ) 

;  (invert  ' ( (1  2  3) 

(defun  invert  (ppro) 

(let  ((rppro  (reverse  ppro))) 

(do  (  (ans  (mapcar  ' list  (car  rppro) ) 

(do  (  (ansi  nil 

(cons  (cons  (car  tmpl) 
ansi)  ) 

(tmpl  (car  nav)  (cdr  tmpl)) 
(tmp2  ans  (cdr  tmp2))) 

((null  tmpl)  (nreverse  ansi)))) 
(nav  (cdr  rppro)  (cdr  nav) ) ) 

( (null  nav)  ans) ) ) ) 


(car  tmp2) ) 


ans)  ) 
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mat.l 

(t  (invertadd  (addsomany  Is  nr)  t 

(odr  tmp)  )  ) 

(  (null  tmp)  (nreverse  ans)  )  )  ) 


(defun  addsomany  (lis  nl) 


(  (ans  nil 

(cons 


(tmp  lis)  ) 
(  (null  tmp) 


(do  ((ansi  0  (+$  (car  tmp)  ansi)) 

(junk  nil  (setq  tmp  (cdr  tmp))) 
(n2  nl  (1-  n2) ) ) 

( (zerop  n2)  ansi) ) 
ans)  ) 

(nreverse  ans) ) ) ) 


(defun  invertadd  (lis  nl) 

(let  ((temp  (lisdiv  lis  nl) ) ) 
(do  ( (ans  (car  temp) 

(do  (  (ansi  nil 


(do  (  (ansi  nil 

(cons  (+5  (car  tmp)  (car  ans2) )  ansi)) 
(ans2  ans  (cdr  ans2)) 

(junk  nil  (setq  tmp  (cdr  tmp))) 

(n2  nl  (1-  n2 ) ) ) 

( (zerop  n2)  (nreverse  ansi)))) 

(tmp  (cadr  temp)  )  ) 

(  (null  tmp)  ans) ) ) ) 


(defun  invertl (ppro) 

(let  ( (rppro  (reverse  ppro))) 

(do  (  (ans  (car  rppro) 

(do  ( (ansi  nil 

(cons  (append  (car  tmpl)  (car  tmp2) ) 
ansi) ) 

(tmpl  (car  nav)  (cdr  tmpl)) 

(tmp2  ans  (cdr  tmp2))) 

((null  tmpl)  (nreverse  ansi)))) 

(nav  (cdr  rppro)  (cdr  nav) ) ) 

( (null  nav)  ans) ) ) ) 

;  (matdiv  ’(1234)  ’(.5  1.3  2.0  3.0))  «>  (2.0  2.0  1.5  1.333) 
(defun  matdiv  (bel  y) 

(declare  (flonum  y)  ) 

(do  ( (ans  nil 

(cons  ( / S  (car  tmpl)  (car  tmp2) ) 
ans)  ) 

(tmpl  bei  (cdr  tmpl)  ) 

(tmp2  y  (cdr  tmp2)  )  ) 

((null  tmpl)  (nreverse  ans)))) 


(defun  findcp(ppro) 

(do  ((ans  nil  (cons  (myfix  10000  (norm  (car  tmpl)))  ans)) 
(tmpl  (do  ( (ansi  (car  ppro) 

(do  ( (ans2  nil 

(cons  (outerpro2  (car  tmp3) 
(car  tmp4) )  ans2) ) 
(tmp3  ansi  (cdr  tmp3)) 

(tmp4  (car  tmp2)  (cdr  tmp4)') 
((null  tmp3)  (nreverse  ans2) j ) ) 
(tmp2  (cdr  ppro)  (cdr  tmp2))) 

((null  tmp2)  (invert  ansi))) 


(tmp2  (cdr  ppro)  ( 
((null  tmp2)  (inver 
(cdr  tmpl)  )  ) 

((null  tmpl)  (nreverse  ans)))) 


(defun  myequal  (lsl  ls2) 

(do  ((tmpl  lsl  (cdr  tmpl)) 

(tmp2  ls2  (cdr  tmp2))) 

(  (or  (null  tmpl) 

(null  tmp2) 

(not  (mydiff  (car  tmpl)  (car  tmp2)))) 
(and  (null  tmpl)  (null  tmp2) ) ) ) ) 

(defun  mydiff  (x  y) 

(decLare  (tlonum  x  y) ) 

(and  (<  (-$  y  x)  precision) 

(<  ( - S  x  y)  precision))) 

(defun  msendal (namh  slotset  slotget  val) 


(send  namh  slotset 

(nreverse  (cons  val  (nreverse  (send  namh  slotget ) ) ) ) ) ) 

(defun  mspsend  (lnkh  slot  val) 

(cond  ( (myequal  (send  lnkh  slot)  val) 

(cond  ((equal  slot  '  :pi)  (send  lnkh  ':set-pi  val)  nil) 
((equal  slot  lambda)  (send  lnkh  set-lambda  va 
( (equal  slot  ' :pi) 

(send  lnkh  ':set-pi  val)  (send  lnkh  ':bnode)) 

((equal  slot  lambda) 

(send  lnkh  ':set-lambda  val)  (send  lnkh  ':tnode)))> 


■=-=net .  1 
At  a  node 


(declare  (macros  t)) 

(declare  (special  myinpport  precision  myhash 
(defvar  tobe-updated  nil) 

(defvar  all-nodes  nil) 

(defvar  all-links  nil) 

(defvar  all-r.odesh  nil) 

(defvar  aii-linksh  nil) 

(defmacro  mresetO 
'  (progn ( ) 

(setq  myhash  (make-equal-hash-table)) 
(mdefflavor  node 

( (values  '  (True  False) ) 

(rank  nil) 

(tlinks  nil) 

(blinks  nil) 

(prior  nil) 

(parranks  nil) 

(parprobs  nil) 

(condprol  nil) 

(condpro2  nil) 

(belief  nil) ) 

0 

: set table- instance -variables) 


(mdefflavor  link 
(  (tnode  nil) 

(bnode  nil) 

(indpro  nil) 

(lambda  nil) 

(pi  nil)  ) 

0 

: settable-instance-variables) ) ) 


(mreset)  ;  initializing 

(setq  myhash  (make-equal-hash-table)) 

(mdefflavor  node 

((values  '(True  False)) 

(rank  nil) 

(tlinks  nil) 

(blinks  nil) 

(prior  nil) 

(parranks  nil) 

(parprobs  nil) 

(condprol  nil) 

(condpro2  nil) 

(belief  nil) ) 

0 

: set table- instance- variables) 

(mdefflavor  link 
( (tnode  nil) 

(bnode  nil) 

(indpro  nil) 

(lambda  nil) 

(pi  nil)) 

0 

: set table- instance- variables) 


(defun  mdescribe (nnam) 

(describe  (gethash-equal  nnam  myhash)  ) ) 

(defun  shownodesO  (mapc  'mdescribe  all-nodes)) 

(defun  showlinksO  (mapc  'mdescribe  all-links)) 

(defun  shownetwork ( )  (mapc  'mdescribe  (append  all-nodes  all-links))) 

;;  - updateall  - 

(defun  updateall-dn (Soptional  (what-node  nil)) 

(let  ((tobe-updated  (cond  (what-node  (list  what-node)) 

(t  all-nodes) ) ) 

(current ) ) 

(while  tobe-updated 

(setq  current  (gethash-equal  (car  tobe-updated)  myhash) 
tobe-updated  (cdr  tobe-updated) ) 


(send  current.  ':update)))) 


(defun  updateal 1-bn ( Sopt ional  (what-node  nil)) 

(let  ((tobe-updated  (cond  (what-node  (list  what-node)) 

(t  all-nodes) ) ) 

(current ) ) 

(while  tobe-updated 

(setq  current  (gethash-equal  (car  (last  tobe-updated)) 
myhash) 

tobe-updated  (reverse  (cdr  (reverse  tobe-updated)))) 
(send  current  ’  :update) ) ) ) 

(defun  updatea 11-dp ( Sopt iona 1  (what-node  nil)) 

(let  ((tobe-updated  (cond  (what-node  (list  what-node)) 

(t  a  11-nodes) ) ) 

(current ) ) 

(while  tobe-updated 

(setq  tobe-updated  (remove-duplicates  tobe-updated) 

current  (gethash-equal  (car  tobe-updated)  myhash) 
tobe-updated  (cdr  tobe-updated) ) 

(send  current  ':update)))) 

(defun  updatea 1 1-dpe (Sopt ional  (what-node  nil)) 

(let  ((tobe-updated  (cond  (what-node  (list  what-node)) 

(t  a.il-nodes)  )  ) 

(current) ) 

(while  tobe-updated 

(setq  tobe-updated  (remove-duplicates  tobe-updated  t) 

current  (gethash-equal  (car  tobe-updated)  myhash) 
tobe-updated  (cdr  tobe-updated) ) 

(send  current  ':update)))l 

(defun  updateall-br (Soptional  (what-node  nil)) 

(let  ((tobe-updated  (cond  (what-node  (list  what-node)) 

(t  all-nodes) ) ) 

(current ) ) 

(while  tobe-updated 

(setq  tobe-updated  (remove-duplicates  tobe-updated) 

current  (gethash-equal  (car  (last  tobe-updated)) 
myhash) 

tobe-updated  (reverse  (cdr  (reverse  tobe-updated)))) 
(send  current  ':update)))) 

; (defun  updateal 1-bre ( Sopt iona 1  (what-node  nil)) 

;  (let  ((tobe-updated  (cond  (what-node  (list  what-node)) 

;  (t  all-nodes) ) ) 

;  (current)) 

;  (while  tobe-updated 

;  (setq  tobe-updated  (remove-duplicates  tobe-updated  t) 

;  current  (gethash-equal  (car  (last  tobe-updated) ) 

;  myhash) 

;  tobe-updated  (reverse  (cdr  (reverse  tobe-updated)))) 

;  (send  current  ':update))J) 

;;;  end  updating - 

(defun  showbeliefs (Soptional  (ofwhat  all-nodes)) 

(cond  ((atom  ofwhat)  (msg  (N  1)  "belief  of  "  ofwhat  "  is  ’’ 

(C  35)  (msend  ofwhat  ':belief))) 

(t  (rnapc  (flambda(x) 

(msg  (N  1)  "  belief  of  "  x  "  is  " 

(C  35)  (msend  x  '.-belief))) 

ofwhat ) ) ) ) 

(defun  showcons (Soptional  (ofwhat  all-links)) 

(msg  (N  1)  (B  30)  "pi"  (B  10)  "lambda") 

(cond  ((atom  ofwhat) 

(msg  (N  1)  ofwhat  !C  25)  "  -->  "  (msend  ofwhat  ' :pi)  (C  55) 

(msend  ofwhat  lambda))) 

(t  (rnapc  (flambda(x) 

(msg  (N  1)  x  (C  25!  "  — >  "  (msend  x  '  :pi)  (C  55) 

(msena  x  lambda) ) ) 

ofwhat) ) ) ) 

(defun  showlamhdas (Sopt ional  (ofwhat  all-links)) 

(cond  ((atom  ofwhat)  (msg  (N  1)  "lambda  of  "  ofwhat  "  is  " 

(C  35)  (msend  ofwhat  ’.lambda))) 

(t  (rnapc  (f lambda (x) 

(msg  (N  1)  "  lambda  of  "  x  "  is  " 


ofwhat )  )  )  ) 


net.l 

(C  35)  (msend  x  lambda))) 


(defun  showpis (soptional  (ofwhat  all-links)) 

(cond  ((atom  ofwhat)  (msg  (N  1)  "pi  of  "  ofwhat  "  is  " 

(C  35)  (msend  ofwhat  '  : p i )  )  ) 

(t  (mapc  (flambda(x) 

(msg  (N  1)  "  pi  of  "  x  "  is  " 

(C  35)  (msend  x  '  : p i ) ) > 


ofwhat) ) ) ) 


(defmethod  (node  :getallpis)  () 

(cond  (tlinks  (do  (  (ans  nil 

(cons  (send  (gethash-equal 

(car  tmpl)  mynash)  ’ :pi) 

ans)  ) 

(tmpl  tlinks  (cdr  tmpl))) 

((null  tmpl)  (nreverse  ans)))) 

(t  (list  prior) ) ) ) 


(defmethod  (node  :getalllambdas)  () 

(cond  (blinks  (do  ((ans  nil 

(cons  (send  (gethash-equal 

(car  tmpl)  myhash) 
' : lambda) 

ans)  ) 

(tmpl  blinks  (cdr  tmpl)  )  ) 

((null  tmpl)  (nreverse  ans)))) 

(t  (list  prior) ) ) ) 


(defmethod  (node  .-update)  () 

(let*  ( (ptlinksln  (length  tlinks)) 

(pblinksln  (length  blinks)) 

(allpis  (send  self  ' rgetallpis) ) 

(alllambdas  (send  self  ' igetalllambdas)  ) 

(piout  (outerpro  allpis)) 

(prelambda  (termpro  alllambdas)) 

(bel)  (prepi)  (contlam)) 

(cond  ((  =  ptlinksln  0)  ;  ***  no  top  links  *** 

( setq  bel  (termpro2  prelambda  piout))) 

(t 

(setq  bel 

(termpro2 

(myfloat  100000000 
(do  (  (ans  nil 

(cons  (do  (  (ansi  0 

(+  ansi 

(*  (car  mtl) 

(car  mt2) ) ) ) 
(mtl  (car  tempi) 

(cdr  mtl) ) 

(mt2  temp2  (cdr  mt2))) 

( (null  mtl)  ansi) ) 

ans)  ) 

(tempi  condpro2  (cdr  tempi)) 

(temp2  (myfix  10000  piout))) 

((null  tempi)  (nreverse  ans)))) 
prelambda) 

contlam 

(myfloat  100000000 
(do  (  (ans  nil 

(cons  (do  (  (ansi  0  (+  ansi 

(*  (car  mtl) 

(car  mt2) ) ) ) 

(mtl  (car  tempi)  (cdr  mtl)) 
(mt2  temp2  (cdr  mt2))) 

(  (null  mtl)  ansi)  ) 


ans)  ) 

(tempi  condprol  (cdr  tempi)) 
(temp2  (myfix  10000  prelambda))) 

.  ((null  tempi)  (nreverse  ans))))))) 

(send  self  '.-set -belief  (norm  bel));  update  belief 

(do  ((tempi  blinks  (cdr  tempi));  update  pis 


(temp2  alllambdas  (cdr  temp2) ) ) 

( (null  tempi) ) 

(let  ( (temp3  (mspsend  (gethash-equal  (car  tempi) 

mybasb) 

' :pi  (matdiv  bel  (car  temp2))))) 

(cond  (temp3  (push  temp3  tobe-updated) ) ) ) ) 

(cond  ( (=  ptlinksln  1);  update  lambdas 

(let  ((temp  (mspsend  (gethash-equal  (car  tlinks)  myhash) 
lambda  contlam))) 

(cond  (temp  (push  temp  tobe-updated) ) ) ) ) 

( (>  pt linksln  1) 

(do  (  (tempi  tlinks  (cdr  tempi) ) 

(temp2  (maklis  (length  parranks))  (cdr  temp2) ) 
(temp3  (termpro2  contlam  piout) ; ) 

(  (null  tempi)  ) 

(let*  (  (tclh  (gethash-equal  (car  tempi) 
myhash) ) 

(temp  (mspsend  tclh  ': lambda 
(arrange  temp3 

parranks  (car  temp2) 

(send  tclh  ' :pi) ) ) ) ) 

(cond  (temp  (push  temp  tobe-updated) )))))))) 


(defun  cnet  0 

(msg  (N  1)  (ptime)  (N  1)) 

(setq  precision  I/S  1.0  (expt  10  4))) 

(setq  float-format  "%.4g") 

(msg  (N  1)  "  Name  of  the  input  file  to  load  :  ") 

( load  ( read) ) 

(setq  all-nodes  (get-insts  'node) 
all-links  (get-insts  'link) 
all-nodesh  (do  ( (ans  nil 

(cons  (gethash-equal  (car  tmp)  myhash) 
ans) ) 

(tmp  all-nodes  (cdr  tmp))) 

((null  tmp)  (nreverse  ans))) 
all-linksh  (do  ((ans  nil 

(cons  (gethash-equal  (car  tmp)  myhash) 
an3)  ) 

(tmp  all-links  (cdr  tmp))) 

( (null  tmp)  (nreverse  ans) ) ) ) 

(msg  (N  1)  "  Initialize  ?  ") 

(and  (ttyesno)  (init-net)  (down-load-all)) 

\msg  (N  1)  (ptime)  (N  1)) 

(updatea.ll-br) 

(msg  (N  1)  (ptime)  (N  1))) 


(defun  init-net  () 

;  add  tlinks  and  blinks  to  nodes  t  check  cardinality  of  indpro 
(for-each  xh  all-nodesh 

(let  ( (pri  (send  xh  ' :prior) ) ) 

(send  xh  ':set-rank  (length  (send  xh  ':values))) 

(cond  (pri  (send  xh  ':set-prior  (norm  pri))) 

(t  (send  xh  ' :set-prior 

(listsomany  (send  xh  ':rank)  1.0)))) 
(send  xh  ':set-belief  (send  xh  '  :prior) ) ) ) 

(for-each  x  all-links 

(let  ( (xh  (gethash-equal  x  myhash))) 

(msendal  (gethash-equal  (send  xh  '  :tnode)  myhash) 

': set-blinks  ' iblinks  x) 

(msendal  (gethash-equal  (send  xh  ' :bnode)  myhash) 
':set-tlinks  '  :tlinks  x) ) ) 


;  expand  all  nodes 
(for-each  xh  all-nodesh 

(let  ( ( t 1 k  (send  xh  'itlinks))) 

(cond  (tlk  (do  (  (parpro  nil 

(cons  (send  (gethash-equal  (car  tlks) 
myhash)  ': indpro) 


(parrnk  nil 


parpro) ) 


netl 

(cons  (msend  (msend  (car  elks)  '  :tnode) 
'  :  rank) 
parrnk) ! 

(tlks  (reverse  tlk)  (edr  tlks))) 

(  (null  tlks) 

(send  xh  '  :set-parprcbs  parpro) 

(send  xh  '  :  set-parranks  parrnk) 

(send  xh  ' : set-condprol 
(findcp  parpro)) 

(send  xh  ' : set-condpro2 

(invert  (send  xh  ' :condprol) ) ) 

)))))) 

;  expand  all  links 
(for-each  xh  all-linksh 

(send  xh  ':set-pi  (send  (gethash-equal  (send  xh  ' :tnode) 

myhash)  '.-prior)) 

(send  xh  ’ :set-lambaa 
(do  ( (ans  nil 

(cons  (do  (  (ansi  0 

(+$  ansi  (*$  (car  mtl) 

(car  mt2) ) ) ) 

(mtl  (car  teml)  (edr  mtl) ) 

(mt2  tem2  (edr  mt2))) 

(  (null  mtl)  ansi) ) 
ans)  ) 

(teml  (invert  (send  xh  ':indpro)l  (edr  teml)) 

(tem2  (send  (gethash-equal  (send  xh  ' :bnode)  myhash) 

' :prior) ) ) 

((null  teml)  (nreverse  ans))))) 
t) 

(defun  d-l-node  (x) 

(let  ( (xh  (gethash-equal  x  myhash))) 


(msg  (N 

1) 

" (mmake-instance 

“  X  " 

' node" 

(N 

1) 

”  ' :values 

t  II 

(send 

xh 

'  rvalues) 

(N 

1) 

“  ' : rank 

»  ft 

(send 

xh 

' rrank) 

(N 

1) 

"  ' :tlinks 

r  it 

(send 

xh 

'  :t  links) 

(N 

1) 

*  '  .-blinks 

t  it 

(send 

xh 

' rblinks) 

(N 

1) 

n  ' :prior 

t  n 

(send 

xh 

'  rprior) 

(N 

1) 

"  ' :parranks 

t  n 

(send 

xh 

' rparranks) 

(N 

1) 

"  ' :parprobs 

»  ii 

(send 

xh 

' rparprobs) 

(N 

1) 

"  ' : condprol 

/  i# 

(send 

xh 

' rcondprol) 

(N 

1) 

"  ' : condDro2 

/  ii 

(send 

xh 

'  :condpro2) 

(N 

1) 

"  ' : be lief 

i  n 

(send 

xh 

'  :  be  1  ie  f )  " 

(N 

2) 

)  ) 

(defun  d-l-link  (x) 

(let  ( (xh  (gethash-equal  x  myhash))) 

(msg  (N  1)  " (mmake- instance  x  "  'link" 

(SI)"' :tnode  * "  (send  xh  ' :tnode) 

(N  1)  "  ' :bnode  '“  (send  xh  '  :bnode) 

(N  1)  "  ' : indpro  '“  (send  xh  ':indpro) 

(N  1)  "  'rlambda  '”  (send  xh  ':lambda) 

(N  1)  n  '  :pi  '"  (send  xh  '  :pi)  ")” 

(N  2)  )  )  ) 

(defun  down-load-all () 

(msg  (N  1)  — — — NODES— — — ■  <N  1)) 

(mape  'd-l-node  (get-insts  'node)) 

(msg  (N  1)  —————LINKS———"  (N  1)) 

(mape  'd-l-link  (get-insts  'link))) 
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;;;  -*-  Mode:  LISP;  Syntax:  Common-Lisp;  Package:  USER;  Lowercase:  Yes;  3ase:  10;  Fonts :CPTFCNT,  CPTFON1 

;;;  -  graphic  interface  - 

(declare  (macros  t ) ) 

; (eval-when  (load  compile)  (load  '  7801oad.o)) 

(cfasl  ' ~hota/doc/study/cnet /examples/cat /rtk780 . o  ' _device_open  ' rtk-open 
" integer- funct ion" ) 

(getaddress  ' _device_c lose  ' rtk-close  "integer-function") 

(getaddress  ' _device_set_artype  'set-artype  " integer- funct ion" ) 

igetaddress  ' _device_whatalu  'whatalu  " integer- funct ion" ) 
igetaddress  ' _de vice_l ine  'rtk-line  " integer- funct ion" ) 

(getaddress  ' _de vice_rect  ' rtk-rect  " integer- funct ion" ) 

(getaddress  ' _de vice_rect_border  ' rtk-rect-border  "integer-function") 

(getaddress  ' _device_text  ' rtk-text  " integer-funct ion" ) 

(getaddress  ' _device_f lipcol  'flipcol  "integer-function") 

(getaddress  ' _device_erase  ' rtk-erase  " integer-funct ion" ) 

(eval-when  (load)  (rtk-open  1)) 

(defun  graph-pane-width ( )  1280) 

(defun  graph-pane-height ( )  1024) 

(defun  draw-myline  (xO  yO  xl  yl  Soptional  (color  1)  (artype  'tv:alu-xor) ) 

(set-artype  (cond  ( (=  artype  'tv:alu-xor)  #x2) 

(t  #x0) ) ) 

(rtk-iine  xO  yO  xl  yl  color)) 

(defun  draw-mystring  (iname  xl  yl  x2  y2 

Soptional  (fcolor  1)  (bcolor  0)  (dx  8)  (dy  12)) 

(rtk-text  xl  yl  fcolor  bcolor  iname  dx  dy) ) 

(defun  draw-mygray  (Srest  rest) ) 

(defun  draw-myrectangle  (xO  yO  xl  yl  Soptional  (color  1)  (artype  ' tv:alu-xor) ) 

(set-artype  (cond  ( (=  artype  'tv:alu-xor)  #x2) 

(t  #x0) ) ) 

(rtk-rect  xl  yl  (+  xO  xl)  (+  yO  yl)  color)) 

(defun  draw-myrectangle-border  (xO  yO  xl  yl  color)  .  -  - % 

(rtk-rect-border  xO  yO  xl  yl  color))  • 

(defun  clear-graph-pane (Srest  rest) 

(rtk-erase) ) 

(defun  draw-bitblt (srest  rest)) 

(defmacro  tr-graph() 

* (trace  graph-pane-width 
graph-pane-height 
draw-myline 
draw-mystring 
draw-mygray 
draw-myrectangle 
clear-graph-pane 
draw-bitblt) ) 

(defun  testcolO 

(do  (  (yl  0  (+  yl  64)  ) 

(clnum  0) ) 

( (=  yl  1024)  t) 

(do  ( (xl  0  (+  xl  80) ) ) 

( (=  xl  1280)  t) 

(rtk-rect  xl  yl  (+  xl  79)  (+  yl  63)  clnum) 

(rtk-rect-border  xl  yl  (+  xl  79)  (+  yl  63)  0) 

(setf  clnum  (1+  clnum))))) 

(defun  tcls  (Soptional  (fg  1)) 

(do  ( (yl  0  (+  y]  128) ) 

(clnum  0) ) 

( (=  yl  1024)  t) 

(do  ( (xl  0  (+  xl  80) ) ) 

( (-  xl  1280)  t) 

(rtk-rect  xl  yl  (+  xl  79)  (+  yl  127)  clnum) 

(rtk-rect-border  xl  yl  (+  xl  79)  (+  yl  127)  0) 

(rtk-text  (+  xl  yl  0  124  (get_pname  (concat  clnum  "")))) 

(setf  clnum  (next-clnum  clnum  fg) ) ) ) ) 

(defun  next-clnum  (pool  inc) 

(let  ( (tmp  (+  pool  inc))) 

(cond  ( (<  tmp  128)  tmp/ 

(t  (1+  (mod  tmp  inc)))))) 


c 

V 

hmmmmmmmmmm 


7  V.  V 


rtk780.c 


SI'  05/12  1 
08:33:10  j 


♦include  <sys/ioctl ,h> 

♦include  <sys/rtk.h> 

♦  include  <stdio.h'> 

♦include  <signal.h> 

static  char  buff[2048]; 
static  short  set  =  0x800; 
static  int  ramtek; 
static  char  alutype; 

/*  31ack  Red  Orange  Yellow  Green  Blue  Aqua  White  &  8  more  */ 
cr.ar  tabie;1324)  =  f  /*  Actually  should  be  "  table  [  256  J  [  4  ] 

0,0, 0,0, 

0,  0,255,0, 

0,128,255,0, 

0,255,255,  0, 

0,255,0,0, 

255,0,0,0, 

255,255,  0,0, 

255,255,255,0, 

0, 0, 0,  1, 

0,0,  255, 1, 

0, 128,255, 1, 

0,255,255,1, 

0,255,0,1, 

255,0,0,1, 

255,255,0, 1, 

255,255,255,1 
i  ; 

char  tablel [ 1024 ]  =  { 

0,  0,  0,  0, 

0,  0,  63,  0, 

0,  0,  127,  0, 

0,  0,  191,  0, 

0,  0,  255,  0, 


63,  0,  0, 

63,  63,  0, 

63,  127,  0, 

63,  191,  0, 

63,  255,  0, 

127,  0,  0, 

127,  63,  0, 

127,  127,  0, 

127,  191,  0, 

127,  255,  0, 


0,  0, 


191,  63, 

191,  127, 
191,  191, 
191,  255, 


0,  0, 

63,  0, 

127,  0, 

191,  0, 

255,  0, 
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63, 

63, 

63, 
63 , 
63, 
63, 
63, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

127, 

191, 

191, 

191, 

191, 

191, 

191, 


191, 

191, 

1, 

191, 

255, 

X  , 

255, 

0, 

1, 

255, 

63, 

X  , 

255, 

127, 

1, 

255, 

191, 

1, 

255, 

255, 

1, 

0, 

0, 

1, 

0, 

63, 

1, 

0, 

127, 

1, 

0, 

191, 

1, 

0, 

255, 

1, 

63, 

0, 

1, 

63, 

63, 

1, 

63, 

127, 

1, 

63, 

191, 

1, 

63, 

255, 

1, 

127, 

0, 

1, 

127, 

63, 

1, 

127, 

127, 

1, 

127, 

191, 

1, 

127, 

255, 

1, 

191, 

0, 

1, 

191, 

63, 

1, 

191, 

127, 

1, 

191, 

191, 

1, 

191, 

255, 

1, 

255, 

0. 

1, 

255, 

63, 

1, 

255, 

127, 

1, 

255, 

191, 

1, 

255, 

255, 

1- 

0, 
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255, 

63, 

191, 

1 

255, 

63, 

255, 

1 

255, 

127. 

0, 

1 

255, 

127, 

63, 

1 

255, 

127, 

127, 

1 

255, 

127, 

191. 

1 

255, 

127, 

255, 

1 

255, 

191. 

0, 

1 

255, 

191, 

63, 

1 

255, 

191, 

127, 

2 

255, 

191, 

191, 

1 

255, 

191. 

255, 

1 

255, 

255, 

0. 

1 

255, 

255, 

63, 

1 

255, 

255, 

127, 

1 

255, 

255, 

191, 

1 

255, 

255, 

255, 

1 

32, 

32, 

32, 

0 

95, 

95, 

95, 

0 

159, 

159, 

159, 

0 

ievice_open (orientation) 
int  orientation; 

if ((ramtek  =  open ("/dev/ rtk",  21)  <  0)  return(-l); 

r_wtab (tablel,  0,  0,  256,  0)  ; 

alutype  =  0x00; 

buff(0]  =  orientation  &  0x01; 

buff [1]  =  0x27; 

it (write (ramtek,  buff,  2)  !=  2)  return  (-1); 

return  (0) ; 


device_close ( ) 

( 

close ( ramtek) ; 
return (0 ) ; 


device_set_artype (x) 
int  *x; 

switch(*x)  ( 


case 

0: 

alutype  - 

0x00; 

break; 

case 

1 : 

alutype  = 

0x01; 

break; 

case 

2: 

alutype  = 

0x02; 

break; 

case 

3: 

alutype  = 

0x03; 

break; 

case 

4; 

alutype  = 

0x04; 

break; 

case 

5: 

alutype  = 

0x05; 

break; 

case 

6: 

alutype  = 

0x06; 

break; 

case 

7  : 

alutype  = 

0x07; 

break; 

case 

8; 

alutype  = 

0x08; 

break; 

case 

9: 

alutype  = 

0x09; 

break; 

case 

10 

:  alutype 

=  0x0a ; 

break; 

case 

11 

:  alutype 

-  0x0b; 

break; 

case 

12 

:  alutype 

=  0x0c; 

break; 

default 

:  alutype 

=  0x00 1 

break; 

device_whatalu () 

{ 

return  (alutype  -  0x00) ; 

device_line (xO,  yO,  xl,  yl,  color) 
int  *x0,  *y0,  *xl,  *yl,  ‘color; 

register  int  rxO,  ryO,  rxl,  ryl; 

rxO  =  *x0; 
ryO  =  *y0 ; 
rxl  =  ‘xl; 
ryl  =  *y 1 ; 
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buff [0] 
buff [2] 
buff [4! 


=  0x03;  bu f f [ 1 ]  =  OxOE; 

=  0x02;  buff [3]  =  0x88; 

=  ’color  &  OxFF;  buff [5 j  =  0x00; 
buff [6]  =  alutype;  buff [7]  =  OxOO; 

«  rxO  s  OxFF;  buff[9]  =  (rxO  >>  8)  S 
=  ryO  s  OxFF;  buff[ll]  =  (ryO  >>  8) 
=  0x04;  buff [13]  =  0x00; 

=  rxl  &  OxFF;  buff[15]  =  (rxl  >>  8) 


buff  [8] 
buff [10 
buff [12 
bu  f  f ;  1 4 ; 
buff[16]  =  ryl 


0x07; 
i  0x03; 


S  OxFF;  buf f [ 17]  =  (ryl  >>  8) 


S  0x07; 
i  0x03; 


if  (write  (ra.T.tek,  buff.  18)  !=  18)  return  { —  1 )  ; 

return  (0) ; 


;e_rect_bcrder (xO,  yO,  xl,  yl.  color) 
*x0,  *y0,  ’xl,  *yl,  ’color; 


register  int  rxO,  ryO,  rxl,  ryl; 


rxO  =  *x0; 
ryO  =  *yO; 
rxl  =  ’xl; 
ryl  =  ’yl; 


buff [0] 
buff [2] 
buff [4] 
buff [6] 
buff [8] 


=  0x03;  buffil]  =  OxOE; 

=  0x02;  buff [3]  =  0x88; 

=  ’color  &  OxFF;  buff [5]  =  0x00; 

=  alutype;  buff[7]  =  0x00; 

=  rxO  s  OxFF;  buff(9]  -  (rxO  »  8)  &  0x07; 


buff [10] 

= 

ryO 

& 

OxFF; 

bu  f  f ( 1 1 ]  =  (ryO 

>> 

8) 

& 

0x03; 

buff [12] 

= 

OxlC 

i; 

buff [ 13 ]  =  0x00; 

buff [14] 

rxl 

& 

OxFF; 

buf f [ 15 ]  =  (rxl 

>> 

8) 

& 

0x07; 

buff [16] 

= 

ryO 

& 

OxFF; 

bu  f  f [ 1 7 ]  =  (ryO 

>> 

8) 

& 

0x03; 

buff [18] 

= 

rxl 

& 

OxFF; 

buf  f [ 19]  =  (rxl 

>> 

8) 

& 

0x07; 

buff [20] 

= 

ryl 

& 

OxFF; 

buf  f ( 2 1 ]  =  (ryl 

>> 

8) 

& 

0x03; 

buff [22] 

= 

rxO 

& 

OxFF; 

bu f  f  [ 2 3  ]  =  ( rxO 

>> 

8) 

& 

0x07; 

buff [24] 

= 

ryl 

& 

OxFF; 

buf f  [25]  =  (ryl 

>> 

8) 

& 

0x03; 

buff  [26] 

= 

rxO 

& 

OxFF; 

buf f [27]  =  ( rxO 

>> 

8) 

& 

0x07; 

buff  [28] 

= 

ryO 

& 

OxFF; 

buf  f  [29]  =  (ryO 

>> 

8) 

& 

0x03; 

if (write 

(ramtek 

i 

buff. 

30)  !  -  30)  return 

(-1) 

; 

return  (0) 


device_rect (xO,  yO,  xl,  yl,  color) 
int  *x0,  ’yO,  *xl,  *yl,  ’color; 


register  int  rxO,  ryO,  rxl,  ryl; 


rxO  =  *x0; 
ryO  =  »y0; 
rxl  =  ’xl; 
ryl  =  *yl ; 


buff [0] 
buff [2] 
buff [4] 


=  0x02;  buf f [ 1]  =  0x09; 

=  0x44;  buf f [3]  =  0x08; 

=  ’color  &  OxFF;  buff [5]  =  0x00; 
buf f ( 6]  =  rxO  s  OxFF;  buff[7]  =  (rxO  >>  8)  S 
bu f f ( 8 ]  =  ryO  s  OxFF;  buff(9]  =  (ryO  »  8)  s 
buff (10)  =  rxl  i  OxFF;  buff[ll]  =  (rxl  »  8) 
buff ( 12]  =  ryl  s  OxFF;  buff[13)  =  (ryl  »  8) 
buff[14]  =  alutype;  buff[15]  =  0x00; 


0x07; 
0x03; 
i  0x07; 
6  0x03; 


if  (write  (ramtek,  buff,  16)  !=  16)  return  (-1); 

return  (0) ; 


ievice_f  lipcol  fcl) 

return  (  *cl  +  125); 


« 
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device_erase  ( ) 

int  xO,  yO,  xl,  yl,  color; 

xO  =  yO  =  0; 
xl  =  1279; 
yl  «  1023; 
color  =  0; 

return (device_rect  (SxO,  SyO,  Sxl,  Syl,  Scolor! ) ; 


uevice_reset ( ) 

buff [0]  =  0x00;  buff (1 J  =  0x05; 


if (write (ramtek,  buff,  2)  !=  2)  return  (-1)  ; 

return  (0)  ; 


device_text (xO,  yO,  fcolor,  bcolor,  textptr,  dx,  dy) 
int  ’xC,  *y0,  ’fcolor,  ’bcolor,  *dx,  *dy; 
char  ’textptr; 

register  int  wsize,  length; 
register  char  ’bptr; 
register  int  rxO,  ryO; 


rxO  =  *x0 ; 
ryO  =  *y0; 


buff  [0]  =  OxOB;  buff[l]  =  OxOC; 
buff  [2]  =  0x86;  buff[3]  =  0x81; 
buff[4]  =  ’fcolor  &  OxFF;  buff(5) 
buff[6]  =  ’bcolor  s  OxFF;  buff(7] 
bu f f [ 8 ]  =  0x00;  buff(9]  -  0x00; 
buffflO]  =  »dx  s  OxFF;  buff(ll]  = 

buff[ 12]  -  ’dy  s  OxFF;  buff(13)  = 

buff [14]  =  rxO  s  OxFF;  buff(15]  = 

buff  116)  =  ryO  &  OxFF;  buff(17]  = 


=  0x00; 

=  0x00; 

0x00; 

0x00; 

(rxO  >>  8)  &  0x07; 
(ryO  >>  8)  i  0x03; 


length  =  strlen (textptr) ; 
if (length  <=  0)  return(-l); 

if  (length  >  78)  length  =  78;  /*  Maximum  size  string  which  fits  buff  */ 


bu  f  f  [  1 8 ]  =  length  S  OxFF;  buff(19]  =  0x00; 

if  ((wsize  =■  20  +  length)  t  1)  wsize  +  +  ;  /*  number  of  bytes  for  write  */ 


bptr  =  4buf f [20] ; 

while (length--)  *bptr++  =  *textptr++; 


if (write (ramtek,  buff,  wsize)  <  wsize)  return(-l); 
return  (0)  ; 


r_wtab (values,  load_table,  start,  nvals,  3elect_table) 
char  ’values; 

int  load_table,  start,  nvals,  select_table; 

( 

register  i,  j,  k; 
j  -  0; 

if (nvals)  (  /*  Then  must  load  before  selecting  */ 

/*  Load  Auxiliary  Memory  command  —  Device  0  */ 

buf f ( 0 J  -  0x00; 
bufffl]  =  0x03; 

/*  Table  start  address  —  16bit  start,  not  entry  start  ’/ 
buff  (2)  =  (i  =  start  *  2); 

buff (3]  =  ( ( i  >>  8)  +  (load  table  *  2))  S  OxFF; 


/'  Number  of  bytes  to  load  —  4  times  number  of  entries  */ 
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buff[4]  =  (i  =  nvals  *  4)  S  OxFF; 

buff [5 J  =  (i  »  8)  i  OxFF; 

j  =  6; 

for ( i=0 ; i<nvals; i++)  { 

buf f [ j  +  +  ]  =  *values++;  /*  Blue  */ 
buff[j  +  -*-]  =  *values++;  /*  Green  */ 
buff  =  *values++;  /*  Red  */ 

buff[j++]  =  *values++;  /*  And  any  blink. 


/*  Either  zero  or  (6  +  (nvals  *  4))  */ 


buffik++]  =  0x00; 
buff(kt+]  =  0x03; 


/*  Select  table...  */ 


buffik*+]  =  0;  /*  Table  number  */ 

buff[k++i  =  (select_table  *  2)  i  0x06; 


/*  Just  selecting  so  no  actual  writing.. 


buff[k++]  =  0;  /*  Just  selecting  sc 

buff  .'k*  +  J  =  0; 

i  f  ( wr  ite  ( ramtek,  buff,  k)  '■  -  k)  return(-l); 
return (seiect_table) ; 
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SP;  Syntax:  Zetalisp;  Package:  USER;  3ase:  10;  Lowercase:  Yes;-* 
(load  compile)  (load  'sat .o) ) 

=-=net.i  -=-=-=-= 

At  a  node  -  - 


(decla 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 

(defva 


;  (macros  t ) ) 
myoutport ) 

def at: it -out -f i le-name  '  /usr/aic/hota/latest-out.i) 
precision  .0001) 

my  hash  (make-equal-hash-table)  ) 

tobe-updated  nil) 

targetnode  nil) 

all-nodes  nil) 

all-links  nil) 

all-nodesh  nil) 

ali-linksh  nil) 

node-w) 

node-h ) 

node-w2 ) 

node-h2 ) 

node-w4 ) 

node-h4 I 

gp-w  1000) 

gp-h  1000) 

m-x  0 ) 

m-y  0 ) 

ma-x) 

device-type  nil) 
bgc  0) 
fgc  7) 
hlt-c  1) 
first-c  2) 
second-c  3) 
third-c  4) 
fourth-c  5) 
fifth-c  6) 
need-graphics  t) 


(defmacro  f-dotimes ( (count  count-times)  &rest  body) 

* (do  ((, count  0  (1+  .count))) 

(  (  =  .count  .count-times)  t) 

, @body) ) 

(defmacro  hash- f rom-myhash  (%lst) 

’(do  ( (tans  nil  (cons  (gethash-equal  (car  %tmp)  myhash)  %ans) ) 
(%tmp  ,%lst  (cdr  Strap) ) ) 

((null  %trap)  (nreverse  %ans) ) I  I 


(mdefflavor  node 

((i-name  "noname") 

(values  ' (True  False) ) 

(rank  nil) 

(p-x  r.il) 

(p-y  nil) 

(pos  ' (0  0) ) 

(ent  0) 

(imp  0) 

(nd-color  0) 

(tlinks  nil) 

(blinks  nil) 

(prior  r.il) 

(init-prior  nil) 

(parranks  nil) 

(parprobs  nil) 

(condprol  nil) 

(condpro2  nil) 

(belief  nil) 

( init-bel ief  nil)) 

0 

:  set table- instance- variables) 

(mdefflavor  link 

((i-name  "noname") 

(tnode  nil) 

(bnode  nil) 

(indpro  nil) 

(lambda  nil) 
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(init-iambda  nil) 
(pi  nil) 

(init-pi  nil) 

(t-pt  ’  (0  0)  ) 

(b-pt  ’  (3  3) ) 
(mu-info  3)) 


:settabie  - in stance -variables) 


(detun  mdescribe (nnam) 

(describe  (qethash-equal  nnam  myhash))) 


(defun  shownodesO  (.tape  '  mdescribe  all-nodes)  t) 

(defun  showlinksO  (mape  'mdescribe  all-links)  t) 

(defun  shown.etwork  ( )  (mape  'mdescribe  (append  all-nodes  all-links))  t) 


(defun  showbeliefs (Soptional  (ofwhat  all-nodes)) 

(cond  ((atom,  ofwhat)  (msg  (N  1)  “belief  of  "  ofwhat  “  is  " 

(C  35)  (msend  ofwhat  ’ibelief))) 

(t  (mape  (flambda(x) 

(msg  (N  1)  “  belief  of  ”  x  11  is  “ 

(C  35)  (msend  x  ' :belief))) 

ofwhat) ) ) 
t) 


(defun  showcons (4opt ional  (ofwhat  all-links!) 

(msg  (N  1)  (B  30)  "pi"  (3  10)  “lambda") 

(cond  ((atom  ofwhat) 

(msg  (N  1)  ofwhat  (C  25)  "  -->  “  (msend  ofwhat  ' :pi)  (C  55) 

(msend  ofwhat  lambda))) 

(t  (mape  (flambda(x) 

(msg  (N  1)  x  (C  25)  “  — >  “  (msend  x  '  :pi)  (C  55) 

(msend  x  lambda))) 

ofwhat ) ) ) 
t) 


(defun  showlambdas (Soptional  (ofwhat  all-links)) 

(cond  ((atom  ofwhat)  (msg  (N  1)  "lambda  of  "  ofwhat  "  is  " 

(C  35)  (msend  ofwhat  -lambda))) 

(t  (mape  (f lambda (x) 

(msg  (N  1)  "  lambda  of  "  x  "  is  “ 

(C  35)  (msend  x  lambda))) 

ofwhat ) ) ) 
t) 


(defun  showpis  (Soptional  (ofwhat  all-links)) 

(cond  ((atom  ofwhat)  (msg  (N  1)  "pi  of  "  ofwhat  "  is  " 

(C  35)  (msend  ofwhat  ’:pi))) 

(t  (mape  (flambda(x) 

(msg  < N  1 )  “  pi  of  "  x  "  is  " 

(C  35)  (msend  x  ' : pi) ) ) 

ofwhat) ) ) 
t) 


(defmethod  (node  :getallpis)  () 

(cond  (tlinks  (do  (  (ans  nil 

(cons  (send  (g“thash-equal 

(car  tmpl)  myhash)  ' :pi) 

ans)  ) 

(tmpl  tlinks  (edr  tmpl))) 

((null  tmpl)  (nreverse  ans)))) 

(t  (list  prior)  )  )  ) 


(defmethod  (node  : geta 1 1 lambdas)  () 

(cond  (blinks  (do  (  (ans  nil 

(cons  (send  (gethash-equal 

(car  tmpl)  myhash) 
' : lambda) 

ans)  ) 

(tmpl  blinks  (edr  tmpl))) 

((null  tmpl)  (nreverse  ans)))) 

(t  ( list  prior)  )  )  ) 


(defmethod  (node  :update)  () 

(let*  ((ptlinksln  (length  tlinks)) 
(pblinksln  (length  blinks)) 
(ailpis  (send  seif  '  .-getal lpis)  ) 
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(alllambdas  (send  self  '  :qetalllambdas) ) 
(piouc  (norm  (outerpro  allpis))) 
(prelambda  (norm  (termpro  alliambdas) ) ) 
(bell  (prepi)  (contlam)) 


no  Cop  links  *** 


;;  high- light  the  node 
(send  seif  ' :nigh-iight  t) 

(cor.d  (  (=  ptlinksln  0) 

(setq  bel  (termpro2  prelambda  piout))) 

(t 

(setq  bel 

(termpro2 

(myfioat  100000000 

(do  (  (ans  nil 

(cons  (do  (  (ansi  0 

(+  ansi 

(’  (car  mtl) 
(car  mt2) ) ) ) 
(mtl  (car  tempi) 

(cdr  mtl) ) 

(mt2  temp2  (cdr  mt2))) 

( (null  mtl)  ansi)  ) 
ans)  ) 

(tempi  condpro2  (cdr  tempi) ) 

(temp2  (myfix  10Q00  piout))) 

(  (null  tempi)  (nreverse  ans) ) ) ) 

prelambda) 


contlam 

(myfioat  100000000 
(do  ( (ans 


nil 

(cons 


(tempi 
(temp2 
!  (null 


(do  (  (ansi  0  (+  ansi 

(*  (car  mtl) 

(car  mt2) ) ) ) 

(mtl  (car  tempi)  (cdr  mtl) ) 
(mt2  temp2  (cdr  mt2))) 

(  (null  mtl)  ansi)  ) 
ans)  ) 

condprol  (cdr  tempi)) 

(myfix  10000  prelambda))) 
tempi)  (nreverse  ar.s)  )))))) 


(let  (  (oldbel  belief)) 

(send  self  ':set-belief  (norm  bel))  ;  update  belief 

(send  self  ' :draw-pic  oldbel)) 

(do  ( (tempi  blinks  (cdr  tempi)  )  ;  update  pis 

(temp 2  alllambdas  (cdr  temp2) ) ) 

(  (null  tempi) ) 

(msend  (car  tempi)  ' :draw-pic  t) 

(let  ( (temp3  (mspsend  (gethash-equal  (car  tempi) 

myhash) 

' :pi  (norm  (matdiv  bel  (car  temp2) ) ) ) ) ) 
(cond  (temp3  (push  temp3  tobe-updated) ) ) ! 

(msend  (car  tempi)  ' :draw-pic) ) 

(cond  ( (=  ptlinksln  1)  ;  update  lambdas 

(msend  (car  tlinks)  ' :draw-pic  t) 

(let  ((temp  (mspsend  (gethash-equal  (car  tlinks)  myhash) 
lambda  (norm  contlam)))) 

(cond  (temp  (push  temp  tobe-updated)))) 

(msend  (car  tlinks)  ' :draw-pic) ) 

(  (>  ptlinksln  1) 

(do  ((tempi  tlinks  (cdr  tempi)) 

(temp2  (maklis  (length  parranks) )  (cdr  temp2) ) 
!temp3  (termpro2  contlam  piout))) 

(  (null  tempi) ) 

(msend  (car  tempi)  ' :draw-pic  t) 

(let*  (  (tclh  (gethash-equal  (car  tempi) 

myhash) ! 

(temp  (mspsend  tclh  lambda 
(norm 

(arrange  temp3 

parranks  (car  temp2) 
(send  tclh  '  :pi)  )  )  )  )  ) 
(cond  (temp  (push  temp  tobe-updated) ) ) ) 

(msend  (car  tempi)  ' :draw-pic) ) ) ) 
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;;  de-h iqn- 1 ight  the  node 
(send  seif  *  -.high-light  nil))) 


(defmethod  (node  :fir.d-ys)  () 

"  finds  the  y-co-ordmate  (relative)  of  the  node  in  the  network” 

(co.od  (p-y) 

(t  (let  ( (prnts  (do  (  (ans  nil 

(cons  (gethash-equa 1 

(msend  (car  temp)  '  :tnode)  myhash) 
ans)  ) 

(temp  tlinks  (cdr  temp))) 

(  (null  temp)  ans) ) ) ) 

(send  self  ':set-p-y 

(cond  ( (null  prnts)  1) 

(t  (+  1 

(do  ((ans  (send  (car  prnts)  ':find-ys) 

(max  ans  (send  (car  temp)  ':find-ys))) 
(temp  (cdr  prnts)  (cdr  temp))) 

(  (null  temp)  ans) ) 

)))))))) 


(defun  find-xys() 

”  finds  x,y  positional  co-ordinates  (relative)  of  all  nodes 
in  the  network  and  save  them  as  p-x  and  p-y  in  the  node.  " 

(setq  m-y  0  m-x  0)  ; re-initializing 

(for-each  j  all-nodesh  ; re- ini t ia lizing 

(send  j  ':set-p-x  nil)  (send  j  ':set-p-y  nil)) 

(for-each  j  all-nodesh 

(setq  m-y  (max  m-y  (send  j  '  :  f ind-ys) ) ) ) 

(setf  ma-x  (array  nil  t  m-y  2)) 

(let  ( (pre  (do  ((ans  nil  (cond  ( (=  m-y  (msend  (car  tmp)  ' : p— y) ) 

(cons  (car  tmp)  ans) ) 

(t  ans) ) ) 

(tmp  all-nodes  (cdr  tmp) ) ) 

((null  tmp)  (nreverse  ans)))) 
prel  preh) 

(setq  prel  (length  pre) 

preh  (hash-f rom-myhash  pre) ) 

(f-dotimes 
(jk  m-y) 

(setf  (aref  ma-x  (-  m-y  1  jk)  0)  prel) 

(setf  m-x  (max  m-x  prel)) 

;;  set  p-x  and  p-y  for  the  pre  nodes 
(do  ( (temp  preh  (cdr  temp) ) 

(tempc  1  (1+  tempo))) 

(  (null  temp)  t) 

(send  (car  temp)  ':set-p-x  tempc) 

‘  ■  i  (car  temp)  '  :set-p-y  (-  m-y  jk)  )  ) 

-  pre  (remove-duplicates 
(do  ( (ans  nil 

(cons  (msend  (car  temp)  ':tnode)  ans)) 

(temp  (do  ( (ansi  nil 

(append  ansi 

(send  (car  tempi)  'itlinks))) 
(tempi  preh  (cdr  tempi)  )  ) 

((null  tempi)  ansi)) 

(cdr  temp) ) ) 

((null  temp)  (nreverse  ans))) 
t) 

prel  (length  pre) 

preh  (hash-f rom-myhash  pre))))) 

(defun  find-posO 

"  determinies  the  size  of  each  node  ie .  node-width  and  height  & 
finds  the  absolute  co-ordinates  of  each  node  in  the  network 
(for  the  display  window)  and  saves  them  in  pos  slot  of  each  node. 

Also  finds  the  absolute  co-ordinates  of  each  link  in  the  network 
and  saves  them  T-PT(top  point)  &  B-PT (bottom  point)  of  each  link.  " 
(setq  gp-w  (graph-pane-width)  .-graphic  pane  width 

gp-h  (graph-pane-height)  .-graphic  pane  height 

node-w^ffix  ( / S  gp-w  1.5  m-x)) 
node-h  (fix  (/$  gp-h  1.5  m-y))) 

(or  (evenp  node-w)  (incf  node-w) ) 

(or  (evenp  node-h)  (incf  node-h)) 

(setq  node-w2  (/  node-w  2)  node-h2  (/  node-h  2) 


& 


smmz 

noae-w4  (/  node-w2  2)  node-h4 
(f-dotimes  (x  rr.-y) 

(secf  (aref  ma-x  x  1) 

(-*■  node-w4  node-w2 
(fix  (*S  (-  m-x 


net-img.l 

(/  node-h2  2) ) 


(aref  ma-x  x  0))  0.75  node-w) ) ) ) ) 


(far-each  xh  all-noaesh  ;  node  co-ordinates 

(let  ( (t-x  (send  xh  ':p-x)l 

(t-y  (send  xh  ' :p-y) ) ) 

(send  xh  ' :set-pos 

(list  (+  (aref  ma-x  (1-  t-y)  1) 

(*  (1-  t-x)  (+  node-w  node-w2) ) ) 

(+  node-h2  node-h4  (*  (1-  t-y) 

(  +  node-h  node-h2) ) ) ) ) ) ) 

(for-each  xh  ail-linksh  ;  link  co-ordinates 

(let  ( (yl  (msend  (send  xh  ' :tnode)  ':pos)) 

(y2  (msend  (send  xh  '  :bnode)  '  :pos) ) 
xl  x2  slope  al  bl  a2  b2) 

(setq  xl  (car  yl)  yl  (cadr  yl) 

x2  (car  y2)  y2  (cadr  y2) ) 

(cond  ( (=  xl  x2) 

(setq  al  xl  a2  xl  bl  (+  yl  node-h2)  b2  (-  y2  node-h2) ) ) 
( (>  xl  x2) 

(setq  slope  (/$  (float  (-  y2  yl) )  (-  x2  xl) ) 

al  (max  (-  xl  node-w2) 

(fix  (+S  xl  ( / S  node-h2  slope)))) 
bl  (min  (+  yl  node-h2) 

(fix  (-S  yl  (*$  node-w2  slope)  -0.999))) 
a2  (min  (fix  (-$  x2  (/$  node-h2  slope)  -0.999)) 

(+  x2  node-  w2) ) 
b2  (max  (-  y2  node-h2) 

(fix  (+$  y2  (*$  node-w2  slope)))))) 

(t  (setq  slope  ( / S  (float  (-  y2  yl))  (-  x2  xl)) 


al 

(min 

(fix 

<+$  xl  (/$ 

node-h2 

slope) 

0.999)  ) 

(+  x) 

node-w2) ) 

bl 

(min 

<  +  yl 

node-h2) 

(fix 

(+S  yl  !*$ 

node-w2 

slope) 

0.999) ) ) 

a2 

(max 

(-  x2 

node-w2) 

(fix 

(-$  x2  (/$ 

node-h2 

slope) ) ) ) 

b2 

(max 

(-  y2 

node-h2) 

(fix 

(-$  y2  (*$ 

node-w2 

slope) )))))) 

(send  xh  ':set-t-pt  (list  al  bl) ) 

(send  xh  ':set-b-pt  (list  a2  b2 ) ) ) ) ) 

(defmethod  (node  :high-liqht)  (Soptional  (fig  t ) ) 

(let  ( (xl  (-  (car  pos)  node-w2) ) 

(x2  (+  (car  pos)  node-w2)) 

(yl  (+  10  (-  (cadr  pos)  node-h2) ) ) 

(y2  (  +  (cadr  pos)  node-h2))) 

( dr aw-my rectangle-border 

xl  yl  x2  y2  (cond  (fig  (+  8  hlt-c) )  (t  fgc) ) ) ) ) 

(defmethod  (node  :draw-pic)  (Soptional  (fig  nil)) 

"  draws  the  node  and  its  beliefs  as  a  histogram  in  the  display 
at  the  proper  place  (ie.  at  the  value  of  POS  of  that  node." 

(let  ( (xl  (-  (car  pos)  node-w2) ) 

(x2  (+  (car  pos)  node-w2) ) 

(yl  (-*  14  (-  (cadr  pos)  node-h2i)) 

( y 2  (+  (cadr  pos)  node-h2) ) 

(nq-h  (-  node-h  15) ) 

(ng-w  (/  node-w  (+  rank  rank  1)))) 

(cond  (fig 

(do  (  (tmpl  belief  (cdr  tmpl)  ) 

( tmp2 ) 

(tmp3  fig  (cdr  tmp3) ) 

(tmp4 ) 

(d-xl  (+  xl  (/  (-  node-w  (*  ng-w  (+  rank  rank  -1)))  2)) 
(+  d-xl  ng-w  ng-w))) 

(  (null  tmpl)  t) 

(setq  tmp2  (fix  (*S  ng-h  (car  tmpl))) 
tmp4  (fix  (*$  ng-h  (car  tmp3)))) 

(cond  ((=  tmp2  tmp4)) 

( (>  tmp2  tmp4 ) 

(draw-myrectangle  ng-w  (-  tmp2  tmp4) 

d-xl  (-  y2  tmp2)  fgc) ) 

( (<  tmp2  tmp4) 

(draw-myrectangle  ng-w  (-  tmp4  tmp2) 

d-xl  (-  y2  tmp4)  bgc) ) ) ) ) 
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(t 

(draw-myrectanqle  node-w  10  xl  (-  yl  13)  fgc) 

(cond  ( (=  nd-color  0) 

(draw-myline  x2  yl  x2  y2  fgc) 

(draw-myline  x2  y2  xl  y2  fgc) 

(draw-myline  xl  y2  xl  yl  fgc)) 

(t  (draw-myrectangle  (-  x2  xl)  (-  y 2  yl)  xl  yl  nd-color)  )  ) 
(draw-mystring  i-name  (  +  xl  2)  (-  yl  13) 

(-  x2  2)  (-  yl  1)  bgc  fgc) 

(do  (  (tmpl  belief  (cdr  tmpl)  ) 

(tmp2) 

(d-xl  (+  xl  (/  (-  node-w  (*  ng-w  (+  rani  rank  -1)))  2)) 

(+  d-xl  ng-w  ng-w) ) ) 

(  (null  tmpl)  t) 

(secq  tmp2  (fix  (*$  ng-h  (car  tmpl)))) 

(draw-myrectangle  ng-w  tmp2 

d-xl  (-  y2  tmp2 )  fgc)))))) 

(defmethod  (link  :draw-pic)  (Soptional  (fig  nil)) 

"  draws  a  line  representing  the  link  on  the  display  area  between 
T-PT  and  B-PT  of  that  link." 

(draw-myline  (car  t-pt)  (cadr  t-pt)  (car  b-pt)  (cadr  b-pt) 

(cond  (fig  (+  8  hlt-c) )  (t  fgc)))) 

(defmethod  (node  :change-bg-color)  () 

"  draws  the  node  and  its  beliefs  as  a  histogram  in  the  display 
at  the  proper  place  (ie.  at  the  value  of  POS  of  that  node." 

(let  ( (xl  (-  (car  pos)  node-w2) ) 

(x2  (+  (car  pos)  node-w2) ) 

(yl  (+  10  (-  (cadr  pos)  node-h2) ) ) 

(y2  (+  (cadr  pos)  node-h2)) 

(ng-h  (-  node-h  12) ) 

(ng-w  (/  node-w  (+  rank  rank  1)))) 

(draw-myrectangle  (-  x2  xl)  (-  y2  yl)  xl  yl  nd-color) 

(draw-myline  x2  yl  x2  y2  fgc) 

(draw-myline  x2  y2  xl  y2  fgc) 

(draw-myline  xl  y2  xl  yl  fgc) 

(do  ((tmpl  belief  (cdr  tmpl)) 

(tmp2) 

(d-xl  (+  xl  (/  (-  node-w  (»  ng-w  (+  rank  rank  -1)))  2)) 

(+  d-xl  ng-w  ng-w))) 

(  (null  tmpl)  t) 

(setq  tmp2  (fix  (*$  ng-h  (car  tmpl)))) 

(draw-myrectangle  ng-w  tmp2 

d-xl  (-  y2  tmp2)  fgc)))) 

(defun  drawpic (Soptional  (fg  nil)) 

”  draws  the  nodes  and  links  on  the  display  area." 

(and  fg  (clear-graph-pane) ) 

(for-each  j  (append  all-nodesh  all-linksh) 

(send  j  ' :draw-pic) ) 
t) 


(defmethod  (link  :cal-mu-info)  0 

"  finds  the  mutual-information  of  a  link  " 

(send  self  set-mu-info 
(do  ( (ans  0  (+$  ans 

(do  ( (ansi  0  (+$  ansi 

(cond  ((zerop  (car  tmp4))  0) 

(  (or  (zerop  (car  tmpl) ) 

(zerop  (car  tmp2) ) )  25.0) 
(t 

(*$  (car  tmp4) 

(log  (/$  (car  tmp4) 

(car  tmpl) 

(car  tmp2) ))))))) 

(tmp2  tmp5  (cdr  tmp2)) 

(tmp4  (car  tmp3)  (cdr  tmp4))) 

((null  tmp4)  ansi)))) 

(tmpl  (msend  bnode  ' :belief) 

(cdr  tmpl) ) 

(tmp3  indprc 

(cdr  tmp3)) 

(tmp5  (msend  tnode  ':belief))) 

(  (null  tmpl)  ans) ) ) ) 
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(node  real-imp) () 


(let  ((sumtop  (do  ( (ans  0  (+$  ans  (msend  (car  temp)  ' :mu-info) ) ) 
(temp  tlinks  (cdr  temp) ) ) 

( (null  temp)  ans) ) ) 

(sumbot  (do  ((ans  0  (+$  ans  (msend  (car  temp)  'rmu-info))) 
(temp  blinks  (cdr  temp))) 

(  (null  temp)  ans) ) ) 
newnodesh  tmph) 

(for-each  x  (hash-from-myhash  tlinks) 

(seta  tmph  (gethash  (send  x  'rtnode)  myhash) ) 

(cond  ((send  tmph  ':imp)  nil) 

(t  (send  tmph  ':set-imp 

(/$  (*$  imp  (send  x  ':mu-info)J  sumtop) ) 
(push  tmph  newnodesh) ) ) ) 

(for-each  x  (hash-from-myhash  blinks) 

(setq  tmph  (gethash  (send  x  ' :bnode)  myhash)) 

(cond  ((send  tmph  ':imp)  nil) 

(t  (send  tmph  set-imp 

( / S  <*S  imp  (send  x  ' :mu-info) )  sumbot)) 
(push  tmph  newnodesh) ) ) ) 

(for-each  y  newnodesh  (send  y  ' :cal-imp) ) ) ) 


(defun  f ind- importance ( ) 

”  finds  the  mutual  information  of  each  link  and  then  finds  the 
importance  factors  of  each  node  in  the  network." 

;;  first  find  mutual  information  of  each  link 
(for-each  x  all-linksh  (send  x  ' :cal-mu-info) ) 

;;  then  find  the  importance  factors  of  each  node 
(or  (gethash  targetnode  myhash) 

(set-target-node  1) ) 

(for-each  x  all-nodesh  (send  x  ':set-imp  nil)) 

(msend  targetnode  ':set-imp  1.0) 

(msend  targetnode  ' :cal-imp) ) 


(defmethod  (node  rca>-ent)()  ;not  needed  for  the  time  being 

"  finds  the  entropy  of  a  node  and  saves  it  in  ENT  of  the  node." 

(send  self  ':set-ent 

(do  ( (ans  0  (+$  ans 

(cond  ( (or  (zerop  (car  tmpl) ) 

(=  (car  tmpl)  1.0))  0) 

(t  (*  (car  tmpl) 

(log  (car  tmpl) )))))) 

(tmpl  belief  (cdr  tmpl))) 

(  (null  tmpl)  ans)  )  )  ) 


(defun  f ind-ent ropy ( ) 

"  finds  the  entropy  of  all  nodes  and  saves  them  in  the  ENT  slot 
of  each  node." 

(for-each  x  all-nodesh  (send  x  ':cal-ent))( 


(defun  set-gray  0  ;  this  is  w.r.t  importance 

“  grays  all  nodes  in  the  network,  the  intensity  depending  on  each 
nodes  importance  in  the  network  with  respect  to  the  target  node." 

(for-each  j  all-nodesh  (send  j  ' : set-nd-coior  0))  ; initializing 

(let*  ( (avg-imp  0) 

(temp  (do  ((ans  nil 

(cons  (list  (send  (car  tmp)  ':imp)  (car  tmp) ) 
ans)  ) 

(tmp  ;; (remove  (gethash-equal  targetnode  myhash)  all-nodesh) 
(hash-from-myhash  (remove  targetnode  all-nodes)) 

(cdr  tmp) ) ) 

(  (null  tmp)  ans) 

(incf-f  avg-imp  (send  (car  tmp)  ' : imp) ) ) ) ) 

(setq  avg-imp  (/$  avg-imp  (length  temp)) 
temp  (sortcar  temp  #'>)) 

(do  ((tmpl  temp  (cdr  tmpl)) 

(tmp2  (list  first-c  second-c  third-c  fourth-c  fifth-c) 

(cdr  tmp2) ) ) 

(  (or  (null  tmpl)  (null  tmp2) )  t) 

(or  (<  (caar  tmpl)  avg-imp) 

(send  (cadar  tmpl)  ' : set-nd-color  (car  tmp2 )))))) 

(defun  init-net() 

;;  add  tlinks  and  blinks  to  nodes  i  check  cardinality  of  indpro 
(for-each  xh  all-nodesh 

(let  (  (pri  (send  xh  ' :prior))) 

(send  xh  ':set-rank  (length  (send  xh  'rvalues))) 


m 
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(cop.d  (pri  (send  xb  ':set-prior  (norm  pri)!) 

(t  (send  xh  ':set-prior 

(listscmany  (send  xh  ':rank) 

< / S  1.0  (send  xh  ' : rank) ) ) ) ) ) 
(send  xh  ':sec-belief  (send  xh  '  .-prior)))) 

(for-each  x  all-links 

(let  ( (xh  (gethash-equal  x  myhash)  )  ) 

(msendal  (gethash-equal  (send  xh  ' :tnode)  myhash) 
':set-blinks  ' :blinks  x) 

(msendal  (gethash-equal  (send  xh  ' :bnode)  myhash) 
' :set-tlinks  ' :tlinks  x) ) ) 


;  expand  all  nodes 

(for-each  xh  all-nodesh 

(let  ( ( t lk  (send  xh  '  :tlinks)  )  ) 

(cond  (tlk  (do  ( (parpro  nil 

(cons  (send  (gethash-equal  (car  tlks) 

myhash)  ’ : indpro) 

parpro) ) 

(parrnk  nil 

(cons  (msend  (use  i  (car  tlks)  ' :tnode) 

' : ranx) 
parrnk) ) 

(tlks  (reverse  tlk)  (cdr  tlks))) 

(  (null  tlks) 

(send  xh  * : set-parprobs  parpro) 

(send  xh  *  : set-parranks  parrnk) 

(send  xh  ' : set-condprol 
( f indcp  parpro) ) 

(send  xh  '  : set-condpro2 

(invert  (send  xh  ' : condprol) ) ) 

)))))> 


;  expand  all  links 

(for-each  xh  all-linksh 

(send  xh  '  :set-pi 

(norm  (send  (gethash-equal  (send  xh  ':tnode) 

myhash)  ' rprior) ) ) 

(send  xh  ' :set-lambda 
(norm 

(do  ( (ans  nil 

(cons  (do  (  (ansi  0 

(+$  ansi  ( *S  (car  mtl) 

(car  mt2) ) ) ) 

(mtl  (car  teml)  (cdr  mtl)) 

(mt2  tem2  (cdr  mt2))) 

(  (null  mtl)  ansi) ) 
ans)  ) 

(teml  (invert  (send  xh  ':indpro))  (cdr  teml)) 

(tem2  (send  (gethash-equal  (send  xh  ' :bnode)  myhash) 
'  :prior)  )  ) 

((null  teml)  (nreverse  ans)))))) 

(find-xys) 

( f ind-pos) 
t) 
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(defun  d-l-node  (x) 

(let  ( (xh  (gethash-equal  x  myhash))) 
(msg  (P  myoutport) 


(N 

1) 

" 

(mmake- in stance 

'  "  x  " 

' node" 

(N 

1) 

" 

'  : i-name 

\” 

"  (send  xh  ':i-name) 

(N 

1) 

" 

' : values 

t  n 

(send 

xh  ' :values) 

(N 

1) 

'  :  rank 

t  ii 

( send 

xh  ' :rank) 

(N 

1) 

'  :p-x 

(send 

xh  '  :p-x) 

<N 

1) 

'  ;p-y 

(send 

xh  ' :p-y) 

(N 

1) 

'  :pos 

(send 

xh  ' :pos) 

(N 

1) 

" 

’  :tlinks 

(send 

xh  '  :tlinks) 

<N 

1) 

" 

' :blinks 

(send 

xh  ' :blinks) 

(N 

1) 

" 

'  :prior 

t  n 

(send 

xh  '  :prior) 

(N 

1) 

'  iparranks 

t  ii 

( send 

xh  ' :parranks) 

(N 

1) 

'  :parprobs 

(send 

xh  ' :parprobs) 

(N 

1) 

" 

' : condprol 

*  n 

(send 

xh  condprol) 

(N 

1) 

” 

'  :condpro2 

t  n 

(send 

xh  ' :condpro2) 

(N 

1) 

' :belief 

i  i» 

( send 

xh  be  lief)  " 

(N 

2)  ) 

) 

V’ 


V  ^ 

■  :r. 


■  i  S  i.  ,  i 
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-link  (x) 


(let  ( ( xh 

(gethash-equal 

x  myhash) ) ) 

(msg  (P 

myoutport ) 

(N 

1)  " (mmake-instance  x  " 

' link" 

(N 

i)  "  - 

i-name 

\”"  (send 

xh  ' 

: i-name 

(N 

i  j  »•  * 

tnode 

' "  (send 

xh  * 

tnode) 

(N 

i)  ■■  ■ 

t-pt 

' "  (send 

xh  ' 

t-pt) 

(S 

i  >  ■ 

bnode 

' "  (send 

xh  ' 

bnode) 

;;; 

i)  ■ 

b-pt 

'  11  (send 

xh  * 

b-pt ) 

(N 

i)  ■ 

indpro 

' "  ( send 

xh  ' 

indpro) 

(N 

i)  • 

lambda 

' “  ( send 

xh  ' 

lambda) 

(N 

i)  ”  ' 

Pi 

'  "  ( send 

xh  ' 

pi)  ")" 

(N 

2))  )  ) 

defun  down- 

•load-all < ) 

"V" 


writes  the  declarations,  values  of  globals  and  node' s  and  link' s 
information  (actually  a  describe!  onto  a  file  so  it  can  be  loaded 
(future  use)  as  it  is  and  rut.  the  program  without  initialization 
of  the  network  which  is  time  consuming.1 


(msg  (N  1) 


Name  of  th“  output  file  to  write 


') 


(setf  myoutport  (outfile  (cond  ((read)) 

(t  default-out-file-name)))) 


(msg  (P 

myoutport) 

(N 

D 

"  (defvar 

gp-w) " 

(N 

i) 

" (defvar 

gp-h) " 

(N 

i) 

"  (defvar 

node-w) " 

(N 

i) 

" (defvar 

node-h) " 

(N 

i) 

" (defvar 

node-w2 ) " 

(N 

i) 

"  (defvar 

node-h2) " 

(N 

i) 

" (defvar 

node-w4 ) " 

(N 

D 

"  (defvar 

node-h4) " 

(N 

i) 

"  (defvar 

m-x)  " 

(N 

D 

"  (defvar 

m-y)  " 

(N 

1) 

"  (setq 

gp-w  "  gp-w 

(N 

1) 

" 

gp-h  ■■  gp-h 

(N 

1) 

node-w  "  node-w 

(N 

1) 

node-h  "  node-h 
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1) 

node-w2  "  node-w2 
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1) 
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1) 
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node-w4  "  node-w4 
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1) 

ii 

node-h4  "  node-h4 

(N 

1) 

ii 

m-x  "  m-x 

(N 

1) 

m-y  »  m-y  ")") 

(msg  (P  myoutport)  (N  1)  -=-=-=-=-=NODES-=-=-=-="  (N  1)) 

(mapc  'd-l-node  (get-insts  'node)) 

(msg  (P  myoutport)  (N  1)  =-=LINKS-=-  =  -=-="  (N  1)  ) 

(mapc  'd-l-link  (get-insts  'link))) 


(defun  copy-info  () 

(for-each  x  all-nodesh 

(send  x  ' : set-init-prior  (send  x  ' tprior) ) 

(send  x  ' : set-init-belief  (send  x  'tbelief))) 

(for-each  x  all-linksh 

(send  x  ' : set-init-lambda  (send  x  'tlambda)) 

(send  x  ' : set-init-pi  (send  x  ' :pi)))) 

(defun  mresetO  ;  reset  the  network 

(let  ( (old-myhash  myhash) ) 

(setq  myhash  (make-equal-hash-table) )  ;  create  new  hash  table 

(puthash  '  (node  +info)  (oethash  '  (node  +info)  old-myhash)  myhash) 
(puthash  '(link  ■••info)  (gethash  '(link  +info)  old-myhash)  myhash) 
(msend  '(node  tinfo)  ':set-insts  nil) 

(msend  '  (link  +info)  '  :set-insts  nil) 

(setq  all-nodes  nil  all-links  nil  all-nodesh  nil  all-linksh  nil))) 


(defun  show-dependence ( ) 
( f ind- importance) 
(set-gray) 

(drawpic  1 ) ) 


(defun  dependency  () 

( set-target-node) 
(show-dependence) ) 


(defun  set-target-node  (Srest  ignore) 
(let  (ttarg  ) 


net-img.l 
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( msg  (N  1)  "  Target  node  :  '■) 

(setq  ttarg  (read)) 

(cond  ((gethash-equal  ttarg  myhash)  (setq  targetnode  ttarg)) 

(t  (set-target-node) ) ) ) ) 

;;;  TOP  level  functions 

(eval-wher.  (laod  compile  eval) 

(setq  precision  .0001  float-format  "%.4g")) 

(setq  float-format  "%.4g") 

(defun  load-init (Soptional  (timefiag  nil)) 

(mreset ) 

(and  timefiag  (msg  IN  1)  (matdiv  (ptime)  '  (60  60))  (N  1))) 

( ,-sg  (N  1)  "  Name  of  the  input  file  to  load  :  ”) 

( load  (read) ) 

(setq  ail-nodes  (get-insts  ’node) 
all-links  (get-insts  ‘link) 
all-r.odesh  (do  (  (ans  nil 

(cons  (gethash-equal  (car  tmp)  myhash) 
ans)  ) 

(tmp  all-nodes  (cdr  tmp) ) ) 

((null  tmp)  (nreverse  ans))) 
all-linksh  (do  ((ans  nil 

(cons  (gethash-equal  (car  tmp)  myhash) 
ans)  ) 

(tmp  all-links  (cdr  tmp) ) ) 

((null  tmp)  (nreverse  ans)))) 

(msg  (N  1)  "  Initialize  ?  ") 

(and  (ttyesno)  (init-net)  (down-load-all) ) 

(and  timefiag  (msg  (N  1)  (matdiv  (ptime)  '(60  60))  (N  1))) 
(drawpic  1) 

(updateall-br) 

(and  timefiag  (msg  (N  1)  (matdiv  (ptime)  '(60  60))  (N  1))) 
(copy-info) ) 

(defun  reset-net  () 

(for-each  x  all-nodesh 

(send  x  ':set-prior  (send  x  '  :  init-prior) ) 

(send  x  ':set-belief  (send  x  ' : init-belief ) ) ) 

(for-each  x  all-linksh 

(send  x  ':set-lambda  (send  x  ' : init-lambda) ) 

(send  x  ':set-pi  (send  x  '  :  init— pi ) ) ) 

(show-dependence) ) 


(defun  updateall-br (Soptional  (what-node  nil)) 

(for-each  x  all-nodesh  ; remove  back-ground  colors 

(cond  ( (=  (send  x  ' :nd-color)  bgc) ) 

(t  (send  x  ' : set-nd-color  bgc) 

(send  x  ' :change-bg-color) ) ) ) 

(let  ( (tobe-updated  (cond  (what-node  (list  what-node)) 

(t  all-nodes) ) ) 


(current ) ) 

(while  tobe-updated 

(setq  tobe-updated  (remove-duplicates  tobe-updated) 

current  (gethash-equal  (car  (last  tobe-updated)) 

myhash) 

tobe-updated  (reverse  (cdr  (reverse  tobe-updated)))) 
(send  current  ' :update) ) ) 

(find- importance) 

(set-gray) 

(for-each  x  all-nodesh  ;set  colors 

(or  (=  (send  x  ':nd-color)  bgc) 

(send  x  ' : change-bg-color) ) )  ) 


====updateall-dn==== 

(setq  current  (gethash-equal  (car  tobe-updated)  myhash) 
tobe-updated  (cdr  tobe-updated) ) 

(send  current  ' :update) ) ) 

====updateall-bn==== 

(setq  current  (gethash-equal  (car  (last  tobe-updated)) 

.  myhash) 

tobe-updated  (reverse  (cdr  (reverse  tobe-updated)))) 


;;;  ====updatea 1 l-dp==== 

;;;  (setq  tobe-updated  (remove-duplicates  tobe-updated) 


net-img.l 

current  (gethash-equal  (car  tobe-updated)  myhash) 
tobe-updated  (cdr  tobe-update  -  ’ 

;;;  ====updateali-dpe==== 

;;;  (setq  tobe-updated  (remove-duplicates  tobe-updated  t) 

;;;  current  (gethash-equal  (car  tobe-updated)  myhash) 

tobe-updated  (cdr  tobe-updated)) 

;;  ====updateall-bre==== 

;;  (setq  tobe-updated  (remove-duplicates  tobe-updated  t) 

;;  current  (gethash-equal  (car  (last  tobe-updated)) 

; ;  myhash) 

; ;  tobe-updated  (reverse  (cdr  (reverse  tobe-updated)))) 

(defun  change-effects (Soptional 
( leaf-nodes 

(do  ( (ans  nil  (cond  ((null  (msend  (car  temp)  '  :blinks) ) 
(cons  (car  temp)  ans) ) 

(t  ans)  )  ) 

(temp  all-nodes  (cdr  temp) ) ) 

(  (null  temp)  ans) ) ) ) 

(and  (atom  leaf-nodes)  (setf  leaf-nodes  (list  leaf-nodes))) 

(for-each  x  leaf-nodes  (get-new-val  x) ) 

(updateal 1-br) 

(or  (member  targetnode  all-nodes)  (set-target-node)) 

(and  targetnode 

(do  (  (tnval  (msend  targetnode  'lvalues)  (cdr  tnval) ) 

(tnbel  (msend  targetnode  ' :belief)  (cdr  tnbel))) 

(  (null  tnval)  t) 

(msg  (N  1)  "  "  (car  tnval)  (C  20)  "  — >  "  (car  tnbel))))) 

(defun  change-causes (Soptional 
(top-nodes 

(do  ((ans  nil  (cond  ((null  (msend  (car  temp)  '  rtlinks) ) 
(cons  (car  temp)  ans)  ) 

(t  ans)  )  ) 

(temp  all-nodes  (cdr  temp))) 

(  (null  temp)  ans) ) ) ) 

(and  (atom  top-nodes)  (setf  top-nodes  (list  top-nodes))) 

(for-each  x  top-nodes  (get-new-val  x) ) 

(updateal 1-br) 

(or  (member  targetnode  all-nodes)  (set-target-node)) 

(and  targetnode 

(do  ( (tnval  (msend  targetnode  ' lvalues)  (cdr  tnval) ) 

(tnbel  (msend  targetnode  '  :belief)  (cdr  tnbel))) 

(  (null  tnval)  t) 

(msg  (N  1)  "  "  (car  tnval)  (C  20)  "  -->  "  (car  tnbel))))) 

(defun  get-new-val (x) 

(prog (xx) 

(msg  (N  1)  "  "x  "s  values  are  (msend  x  ':values)) 

(msg  (N  1)  ”  prior  values:  "  (msend  x  '.’prior)) 

lop 

(msg  (N  1)  "  Enter  new  evidence  :  ") 

(setq  xx  (read) ) 

(cond  (  (null  xx) ) 

(  (=  (length  xx)  (msend  x  ':rank)l 
(msend  x  ':  set-prior  (norm  xx) ) ) 

(t  (msg  (N  1)  "  Error  **wrong  cardinality**.  Try  again.") 

(go  lop) ) ) ) ) 
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